unit uDZMemoryPool;

interface

uses
  SysUtils, Classes, Windows, SyncObjs;

type
  PPoolObjectHeader = ^TPoolObjectHeader;
  TPoolObjectHeader = record
    Next: PPoolObjectHeader;
  end;

  PBlockHeader = ^TBlockHeader;
  TBlockHeader = record
    Next: PBlockHeader;
    Count: Cardinal;
  end;

  TMemoryPool = class(TObject)
  private
    fObjectSize: Cardinal;
    fBlocks: PBlockHeader;
    fLock: TRTLCriticalSection;
    fAllocUnit: Cardinal;
    fFreeList: PPoolObjectHeader;
    fFreeCount: Cardinal;
    fCount: Cardinal;
    procedure SetAllocUnit(const Value: Cardinal);
    procedure AllocBlock(NumObject: Cardinal);
    function CalcBlockSize(Num: Cardinal): Cardinal;
    procedure FreeBlocks;
  public
    constructor Create(Size: Integer);
    destructor Destroy; override;
    function GetMemory: Pointer;
    procedure FreeMemory(Obj: Pointer);
    procedure ReArrange;
    procedure Clear;

    property AllocUnit: Cardinal read fAllocUnit write SetAllocUnit;
    property ObjectSize: Cardinal read fObjectSize;
    property FreeCount: Cardinal read fFreeCount;
    property Count: Cardinal read fCount;
  end;

  TPoolableObject = class(TObject)
  public
    class function NewInstance: TObject; override;
    procedure FreeInstance; override;
  end;

implementation

type
  TMemPoolList = class
  private
    fLock: TRTLCriticalSection;
    fPools: TList;
    procedure ClearPools;
  public
    constructor Create;
    function FindMemoryPool(Size: Cardinal): TMemoryPool; 
    function GetClassPool(cls: TClass): TMemoryPool;
    destructor Destroy; override;
  end;

var
  fMemPoolList: TMemPoolList;

procedure TMemoryPool.AllocBlock(NumObject: Cardinal);
var
  BlockHdr: PBlockHeader;
  Cur, Next: PPoolObjectHeader;
  I: Integer;
  BlockSize: Cardinal;
begin
  BlockSize := CalcBlockSize(NumObject);
  BlockHdr := PBlockHeader(Windows.VirtualAlloc(nil, BlockSize,
    MEM_RESERVE or MEM_COMMIT, PAGE_READWRITE));
  if not Assigned(BlockHdr) then Exit;
  BlockHdr^.Count := NumObject;
  BlockHdr^.Next := fBlocks;
  fBlocks := BlockHdr;
  Inc(BlockHdr);
  Cur := PPoolObjectHeader(BlockHdr);
  for I := 0 to fAllocUnit - 2 do
  begin
    Next := PPoolObjectHeader(Cardinal(Cur) + fObjectSize + SizeOf(TPoolObjectHeader));
    Cur.Next := Next;
    Cur := Next;
  end;
  Cur.Next := fFreeList;
  fFreeList := PPoolObjectHeader(BlockHdr);
  Inc(fFreeCount, NumObject);
  Inc(fCount, NumObject);
end;

function TMemoryPool.CalcBlockSize(Num: Cardinal): Cardinal;
var
  SysInfo: TSystemInfo;
  M: Cardinal;
begin
  Windows.GetSystemInfo(SysInfo);
  Result := SizeOf(TBlockHeader) + fAllocUnit *
    (SizeOf(TPoolObjectHeader) + fObjectSize);
  M := Result mod SysInfo.dwPageSize;
  if M > 0 then Inc(Result, SysInfo.dwPageSize - M);
end;

procedure TMemoryPool.Clear;
begin
  Self.FreeBlocks;
end;

constructor TMemoryPool.Create(Size: Integer);
begin
  fObjectSize := Size;
  fAllocUnit := 1024;
  Windows.InitializeCriticalSectionAndSpinCount(fLock, 100);
end;

destructor TMemoryPool.Destroy;
begin
  FreeBlocks;
  Windows.DeleteCriticalSection(fLock);
  inherited;
end;

procedure TMemoryPool.FreeMemory(Obj: Pointer);
var
  Objhdr: PPoolObjectHeader;
begin
  Objhdr := PPoolObjectHeader(Cardinal(Obj) - SizeOf(TPoolObjectHeader));
  Windows.EnterCriticalSection(fLock);
  Objhdr.Next := fFreeList;
  fFreeList := Objhdr;
  Inc(fFreeCount);
  Windows.LeaveCriticalSection(fLock);
end;

procedure TMemoryPool.FreeBlocks;
var
  BlockHdr: PBlockHeader;
begin
  Windows.EnterCriticalSection(fLock);
  while Assigned(fBlocks) do
  begin
    BlockHdr := fBlocks^.Next;
    Inc(fBlocks);
    Windows.VirtualFree(fBlocks, 0, MEM_RELEASE);
    fBlocks := BlockHdr;
  end;
  fBlocks := nil;
  fFreeCount := 0;
  fCount := 0;
  Windows.LeaveCriticalSection(fLock);
end;

function TMemoryPool.GetMemory: Pointer;
var
  Objhdr: PPoolObjectHeader;
begin
  Windows.EnterCriticalSection(fLock);
  if not Assigned(fFreeList) then Self.AllocBlock(fAllocUnit);
  if not Assigned(fFreeList) then
  begin
    Windows.LeaveCriticalSection(fLock);
    Result := nil;
  end
  else begin
    Objhdr := fFreeList;
    fFreeList := Objhdr.Next;
    Dec(fFreeCount);
    Windows.LeaveCriticalSection(fLock);
    Result := Pointer(Cardinal(Objhdr) + SizeOf(TPoolObjectHeader));
  end;
end;

procedure TMemoryPool.ReArrange;
var
  I: Integer;
  Cur, Next: PPoolObjectHeader;
  BlockHdr: PBlockHeader;
begin
  Windows.EnterCriticalSection(fLock);
  try
    fFreeList := nil;
    BlockHdr := fBlocks;
    while Assigned(BlockHdr) do
    begin
      Cur := PPoolObjectHeader(Cardinal(BlockHdr) + SizeOf(TBlockHeader));
      for I := 0 to BlockHdr^.Count - 2 do
      begin
        Next := PPoolObjectHeader(
          Cardinal(Cur) + fObjectSize + SizeOf(TPoolObjectHeader));
        Cur.Next := Next;
        Cur := Next;
      end;
      Cur.Next := fFreeList;
      fFreeList := PPoolObjectHeader(Cardinal(BlockHdr) + SizeOf(TBlockHeader));
      Inc(fFreeCount, BlockHdr^.Count);
      BlockHdr := BlockHdr.Next;
    end;
  finally
    Windows.LeaveCriticalSection(fLock);
  end;
end;

procedure TMemoryPool.SetAllocUnit(const Value: Cardinal);
begin
  if Value < 256 then fAllocUnit := 256
  else fAllocUnit := Value;
end;

{ TPoolableObject }

procedure TPoolableObject.FreeInstance;
begin
  CleanupInstance;
  fMemPoolList.GetClassPool(ClassType).FreeMemory(Self);
end;

class function TPoolableObject.NewInstance: TObject;
begin
  Result := InitInstance(fMemPoolList.GetClassPool(Self).GetMemory);
end;

{ TMemPoolList }

procedure TMemPoolList.ClearPools;
var
  i: Integer;
begin
  for i := 0 to fPools.Count - 1 do TObject(fPools[i]).Free;
  fPools.Clear;
end;

constructor TMemPoolList.Create;
begin
  InitializeCriticalSectionAndSpinCount(fLock, 100);
  fPools := TList.Create;
end;

destructor TMemPoolList.Destroy;
begin
  ClearPools;
  fPools.Free;
  DeleteCriticalSection(fLock);
  inherited;
end;

function TMemPoolList.FindMemoryPool(Size: Cardinal): TMemoryPool;
var
  i: Integer;
begin
  EnterCriticalSection(fLock);
  try
    for i := 0 to fPools.Count - 1 do
    begin
      Result := TMemoryPool(fPools[i]);
      if Result.ObjectSize = size then Exit;
    end;
    Result := nil;
  finally
    LeaveCriticalSection(fLock);
  end;
end;

function TMemPoolList.GetClassPool(cls: TClass): TMemoryPool;
begin
  EnterCriticalSection(fLock);
  try
    Result := FindMemoryPool(cls.InstanceSize);
    if not Assigned(Result) then
    begin
      Result := TMemoryPool.Create(cls.InstanceSize);
      fPools.Add(Result);
    end;
  finally
    LeaveCriticalSection(fLock);
  end;
end;

initialization
  fMemPoolList := TMemPoolList.Create;

finalization
  fMemPoolList.Free;
  
end.
